C $TITLE: 'NFPAT'
C $NOFLOATCALLS
C
C
C
      SUBROUTINE NFPAT(X,Y,Z,SI,BI,SALP,
     1 T1X,T1Y,T1Z,T2X,T2Y,T2Z,ICON1,ICON2,
     2 AIR,AII,BIR,BII,CIR,CII,CUR,IW,LD,LD3)
C     COMPUTE NEAR E OR H FIELDS OVER A RANGE OF POINTS
      REAL*8 TA,CANG,CTH,STH,CPH,SPH,TMP1,TMP2,TMP3,XOB,YOB,ZOB
      REAL*8 AIR,AII,BIR,BII,CIR,CII
CLARGE:CUR
      COMPLEX CUR
      COMPLEX*16 EX,EY,EZ
      INTEGER*4 ICON1,ICON2,N1,N2,N,NP,M1,M2,M,MP,IPSYM
      COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
      COMMON/FPAT/NTH,NPH,IPD,IAVP,INOR,IAX,THETS,PHIS,DTH,DPH,RFLD,
     1 GNOR,CLT,CHT,EPSR2,SIG2,IXTYP,XPR6,PINR,PNLR,PLOSS,NEAR,NFEH,
     2 NRX,NRY,NRZ,XNR,YNR,ZNR,DXNR,DYNR,DZNR
C***
      COMMON/PLOT/ IPLP1,IPLP2,IPLP3,IPLP4
C***
      DIMENSION X(LD),Y(LD),Z(LD),SI(LD),BI(LD),SALP(LD)
      DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
      DIMENSION CUR(LD3),ICON1(LD),ICON2(LD)
C***
C***    PEAK FIELDS - ADD RPD   RWA 02 APR 89
C***
      DATA TA/1.745329252D-02/,RPD/57.29577951/
C**
C     D      WRITE(*,*) '  NFPAT: START'
C**
      IF (NFEH.EQ.1) GO TO 1
      WRITE(IW,10)
      GO TO 2
1     WRITE(IW,12)
2     ZNRT=ZNR-DZNR
      DO 9 I=1,NRZ
      ZNRT=ZNRT+DZNR
      IF (NEAR.EQ.0) GO TO 3
      CTH=DCOS(TA*ZNRT)
      STH=DSIN(TA*ZNRT)
3     YNRT=YNR-DYNR
      DO 9 J=1,NRY
      YNRT=YNRT+DYNR
      IF (NEAR.EQ.0) GO TO 4
      CPH=DCOS(TA*YNRT)
      SPH=DSIN(TA*YNRT)
4     XNRT=XNR-DXNR
      DO 9 KK=1,NRX
      XNRT=XNRT+DXNR
      IF (NEAR.EQ.0) GO TO 5
      XOB=XNRT*STH*CPH
      YOB=XNRT*STH*SPH
      ZOB=XNRT*CTH
      GO TO 6
5     XOB=XNRT
      YOB=YNRT
      ZOB=ZNRT
6     TMP1=XOB/WLAM
      TMP2=YOB/WLAM
      TMP3=ZOB/WLAM
      IF (NFEH.EQ.1) GO TO 7
      CALL NEFLD (TMP1,TMP2,TMP3,EX,EY,EZ,LD,LD3,X,Y,Z,SI,BI,
     1 SALP,T1Y,T1Z,T1X,T1Y,T1Z,T2X,T2Y,T2Z,ICON1,ICON2,AIR,AII,
     2 BIR,BII,CIR,CII,CUR)
      GO TO 8
7     CALL NHFLD (TMP1,TMP2,TMP3,EX,EY,EZ,LD,LD3,X,Y,Z,SI,BI,
     1 SALP,T1Y,T1Z,T1X,T1Y,T1Z,T2X,T2Y,T2Z,AIR,AII,
     2 BIR,BII,CIR,CII,CUR)
C8     TMP1=CABS(EX)
8     TMP1=ZABS(EX)
      TMP2=CANG(EX)
C      TMP3=CABS(EY)
      TMP3=ZABS(EY)
      TMP4=CANG(EY)
C      TMP5=CABS(EZ)
      TMP5=ZABS(EZ)
      TMP6=CANG(EZ)
C***
C***    PEAK FLD CALCULATION  RWA 02 APR 89  ADD 10 LINES/CHANGE 1
C***
      EZ2 = TMP5*TMP5
      EY2 = TMP3*TMP3
      EX2 = TMP1*TMP1
      AT = EZ2*COS(TMP6*2./RPD)+EY2*COS(TMP4*2./RPD)
     1 +EX2*COS(TMP2*2./RPD)
      BT = EZ2*SIN(TMP6*2./RPD)+EY2*SIN(TMP4*2./RPD)
     1 +EX2*SIN(TMP2*2./RPD)
      CT = AT*AT+BT*BT
      ETOTAL = 0.5*(EZ2+EY2+EX2)+0.5*SQRT(CT)
      ETOTAL = SQRT(ETOTAL)
      WRITE(IW,11)  XOB,YOB,ZOB,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,ETOTAL
CCC   WRITE(IW,11)  XOB,YOB,ZOB,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6
C***
      IF(IPLP1 .NE. 2) GO TO 9
      GO TO (14,15,16),IPLP4
14    XXX=XOB
      GO TO 17
15    XXX=YOB
      GO TO 17
16    XXX=ZOB
17    CONTINUE
      IF(IPLP2 .NE. 2) GO TO 13
      IF(IPLP3 .EQ. 1) WRITE(8,*) XXX,TMP1,TMP2
      IF(IPLP3 .EQ. 2) WRITE(8,*) XXX,TMP3,TMP4
      IF(IPLP3 .EQ. 3) WRITE(8,*) XXX,TMP5,TMP6
      IF(IPLP3 .EQ. 4) WRITE(8,*) XXX,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6
C***
C***    PEAK FIELDS OUTPUT  RWA 02 APR 89  ADD 1 LINE
C***
      IF(IPLP3 .EQ. 5) WRITE(8,*) XXX,ETOTAL
      GO TO 9
13    IF(IPLP2 .NE. 1) GO TO 9
      IF(IPLP3 .EQ. 1) WRITE(8,*) XXX,EX
      IF(IPLP3 .EQ. 2) WRITE(8,*) XXX,EY
      IF(IPLP3 .EQ. 3) WRITE(8,*) XXX,EZ
      IF(IPLP3 .EQ. 4) WRITE(8,*) XXX,EX,EY,EZ
C***
9     CONTINUE
C**
C     D      WRITE(*,*) '  NFPAT: RETURN'
C**
      RETURN
C
C***
C***      PEAK FIELDS PRINTOUT FORMAT  RWA 02 APR 89  CHANGE 17 LINES
C***
10    FORMAT (///,35X,32H- - - NEAR ELECTRIC FIELDS - - -,//,12X,14H-  L
     1OCATION  -,21X,8H-  EX  -,15X,8H-  EY  -,15X,8H-  EZ  -,10X,'- PEA
     |K FIELDS -'/,8X,1HX,10X,
     21HY,10X,1HZ,10X,9HMAGNITUDE,3X,5HPHASE,6X,9HMAGNITUDE,3X,5HPHASE,
     36X,9HMAGNITUDE,3X,5HPHASE,9X,9HMAGNITUDE/,6X,6HMETERS,5X,6HMETERS
     |,5X,6HMETERS,
     48X,7HVOLTS/M,3X,7HDEGREES,6X,7HVOLTS/M,3X,7HDEGREES,6X,7HVOLTS/M,3
     5X,7HDEGREES,9X,7HVOLTS/M)
11    FORMAT (2X,3(2X,F9.4),1X,3(3X,1P,E11.4,2X,0P,F7.2)6X,E11.4)
12    FORMAT (///,35X,32H- - - NEAR MAGNETIC FIELDS - - -,//,12X,14H-  L
     1OCATION  -,21X,8H-  HX  -,15X,8H-  HY  -,15X,8H-  HZ  -,10X,'- PEA
     |K FIELDS -'/,8X,1HX,10X,
     21HY,10X,1HZ,10X,9HMAGNITUDE,3X,5HPHASE,6X,9HMAGNITUDE,3X,5HPHASE,
     36X,9HMAGNITUDE,3X,5HPHASE,9X,9HMAGNITUDE/,6X,6HMETERS,5X,6HMETERS
     |,5X,6HMETERS,
     49X,6HAMPS/M,3X,7HDEGREES,7X,6HAMPS/M,3X,7HDEGREES,7X,6HAMPS/M,3X,7
     5HDEGREES,9X,6HAMPS/M)
      END
C
C
C
      SUBROUTINE NEFLD (XOB,YOB,ZOB,EX,EY,EZ,LD,LD3,X,Y,Z,SI,BI,
     1 SALP,CAB,SAB,T1X,T1Y,T1Z,T2X,T2Y,T2Z,ICON1,ICON2,AIR,
     2 AII,BIR,BII,CIR,CII,CUR)
C
C     NEFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER
C     THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.
C
      REAL*8 ZP,XI,XOB,YOB,ZOB,AIR,AII,BIR,BII,CIR,CII
CLARGE:CUR
      COMPLEX CUR
      COMPLEX*16 ACX,BCX,CCX,EX,EY,EZ
      COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC,
     1 ZRATI,ZRATI2,T1,FRATI
      INTEGER*4 ICON1,ICON2,N1,N2,N,NP,M1,M2,M,MP,IPSYM,IND1,IND2
      COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
      COMMON/DATAJ/S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,
     1 EZS,EXC,EYC,EZC,RKH,IND1,IND2,IPGND,IEXK
      COMMON/GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,
     1 IFAR,IPERF,T1,T2
      DIMENSION X(LD),Y(LD),Z(LD),SI(LD),BI(LD),SALP(LD)
      DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
      DIMENSION CUR(LD3),ICON1(LD),ICON2(LD)
      DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD),
     1 CAB(LD),SAB(LD)
      EQUIVALENCE (T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2Y
     1J,IND1), (T2ZJ,IND2)
C**
C     E      WRITE(*,*) '   NEFLD: START'
C**
      EX=(0.,0.)
      EY=(0.,0.)
      EZ=(0.,0.)
      AX=0.
      IF (N.EQ.0) GO TO 20
      DO 1 I=1,N
      XJ=XOB-X(I)
      YJ=YOB-Y(I)
      ZJ=ZOB-Z(I)
      ZP=CAB(I)*XJ+SAB(I)*YJ+SALP(I)*ZJ
      IF(DABS(ZP).GT.0.5001D0*SI(I)) GO TO 1
      ZP=XJ*XJ+YJ*YJ+ZJ*ZJ-ZP*ZP
      XJ=BI(I)
      IF (ZP.GT.0.9*XJ*XJ) GO TO 1
      AX=XJ
      GO TO 2
1     CONTINUE
2     DO 19 I=1,N
      S=SI(I)
      B=BI(I)
      XJ=X(I)
      YJ=Y(I)
      ZJ=Z(I)
      CABJ=CAB(I)
      SABJ=SAB(I)
      SALPJ=SALP(I)
      IF (IEXK.EQ.0) GO TO 18
      IPR=ICON1(I)
      IF (IPR) 3,8,4
3     IPR=-IPR
      IF (-ICON1(IPR).NE.I) GO TO 9
      GO TO 6
4     IF (IPR.NE.I) GO TO 5
      IF (CABJ*CABJ+SABJ*SABJ.GT.1.E-8) GO TO 9
      GO TO 7
5     IF (ICON2(IPR).NE.I) GO TO 9
C6     XI=DABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
6     XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
      IF (XI.LT.0.999999D0) GO TO 9
      IF (ABS(BI(IPR)/B-1.).GT.1.E-6) GO TO 9
7     IND1=0
      GO TO 10
8     IND1=1
      GO TO 10
9     IND1=2
10    IPR=ICON2(I)
      IF (IPR) 11,16,12
11    IPR=-IPR
      IF (-ICON2(IPR).NE.I) GO TO 17
      GO TO 14
12    IF (IPR.NE.I) GO TO 13
      IF (CABJ*CABJ+SABJ*SABJ.GT.1.E-8) GO TO 17
      GO TO 15
13    IF (ICON1(IPR).NE.I) GO TO 17
C14    XI=DABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
14    XI=ABS(CABJ*CAB(IPR)+SABJ*SAB(IPR)+SALPJ*SALP(IPR))
      IF (XI.LT.0.999999D0) GO TO 17
      IF (ABS(BI(IPR)/B-1.).GT.1.E-6) GO TO 17
15    IND2=0
      GO TO 18
16    IND2=1
      GO TO 18
17    IND2=2
18    CONTINUE
      CALL EFLD (XOB,YOB,ZOB,AX,1)
      ACX=DCMPLX(AIR(I),AII(I))
      BCX=DCMPLX(BIR(I),BII(I))
      CCX=DCMPLX(CIR(I),CII(I))
      EX=EX+EXK*ACX+EXS*BCX+EXC*CCX
      EY=EY+EYK*ACX+EYS*BCX+EYC*CCX
19    EZ=EZ+EZK*ACX+EZS*BCX+EZC*CCX
      IF (M.EQ.0) GOTO 22
20    JC=N
      JL=LD+1
      DO 21 I=1,M
      JL=JL-1
      S=BI(JL)
      XJ=X(JL)
      YJ=Y(JL)
      ZJ=Z(JL)
      T1XJ=T1X(JL)
      T1YJ=T1Y(JL)
      T1ZJ=T1Z(JL)
      T2XJ=T2X(JL)
      T2YJ=T2Y(JL)
      T2ZJ=T2Z(JL)
      JC=JC+3
      ACX=T1XJ*CUR(JC-2)+T1YJ*CUR(JC-1)+T1ZJ*CUR(JC)
      BCX=T2XJ*CUR(JC-2)+T2YJ*CUR(JC-1)+T2ZJ*CUR(JC)
      DO 21 IP=1,KSYMP
      IPGND=IP
      CALL UNERE (XOB,YOB,ZOB)
      EX=EX+ACX*EXK+BCX*EXS
      EY=EY+ACX*EYK+BCX*EYS
      EZ=EZ+ACX*EZK+BCX*EZS
21      CONTINUE
22      CONTINUE
C**
C     E      WRITE(*,*) '   NEFLD: RETURN'
C**
      RETURN
      END
C
C
C
      SUBROUTINE NHFLD (XOB,YOB,ZOB,HX,HY,HZ,LD,LD3,X,Y,Z,SI,BI,
     1 SALP,CAB,SAB,T1X,T1Y,T1Z,T2X,T2Y,T2Z,AIR,
     2 AII,BIR,BII,CIR,CII,CUR)
C
C     NHFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER
C     THE STRUCTURE CURRENTS HAVE BEEN COMPUTED.
C
      REAL*8 XOB,YOB,ZOB,AIR,AII,BIR,BII,CIR,CII
CLARGE: CUR
      COMPLEX CUR
      COMPLEX*16 ACX,BCX,CCX,HX,HY,HZ
      COMPLEX*16 EXK,EYK,EZK,EXS,EYS,EZS,EXC,EYC,EZC
      INTEGER*4 N1,N2,N,NP,M1,M2,M,MP,IPSYM,IND1,IND2
      COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
      COMMON/DATAJ/S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,
     1 EZS,EXC,EYC,EZC,RKH,IND1,IND2,IPGND,IEXK
      DIMENSION X(LD),Y(LD),Z(LD),SI(LD),BI(LD),SALP(LD)
      DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
      DIMENSION CUR(LD3)
      DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD),
     1 CAB(LD),SAB(LD)
      EQUIVALENCE (T1XJ,CABJ),(T1YJ,SABJ),(T1ZJ,SALPJ),(T2XJ,B),(T2Y
     1J,IND1), (T2ZJ,IND2)
C**
C     E      WRITE(*,*) '   NHFLD: RETURN'
C**
      HX=(0.,0.)
      HY=(0.,0.)
      HZ=(0.,0.)
      AX=0.
      IF (N.EQ.0) GO TO 4
      DO 1 I=1,N
      XJ=XOB-X(I)
      YJ=YOB-Y(I)
      ZJ=ZOB-Z(I)
      ZP=CAB(I)*XJ+SAB(I)*YJ+SALP(I)*ZJ
      IF (ABS(ZP).GT.0.5001*SI(I)) GO TO 1
      ZP=XJ*XJ+YJ*YJ+ZJ*ZJ-ZP*ZP
      XJ=BI(I)
      IF (ZP.GT.0.9*XJ*XJ) GO TO 1
      AX=XJ
      GO TO 2
1     CONTINUE
2     DO 3 I=1,N
      S=SI(I)
      B=BI(I)
      XJ=X(I)
      YJ=Y(I)
      ZJ=Z(I)
      CABJ=CAB(I)
      SABJ=SAB(I)
      SALPJ=SALP(I)
      CALL HSFLD (XOB,YOB,ZOB,AX)
      ACX=DCMPLX(AIR(I),AII(I))
      BCX=DCMPLX(BIR(I),BII(I))
      CCX=DCMPLX(CIR(I),CII(I))
      HX=HX+EXK*ACX+EXS*BCX+EXC*CCX
      HY=HY+EYK*ACX+EYS*BCX+EYC*CCX
3     HZ=HZ+EZK*ACX+EZS*BCX+EZC*CCX
      IF (M.EQ.0) GOTO 6
4     JC=N
      JL=LD+1
      DO 5 I=1,M
      JL=JL-1
      S=BI(JL)
      XJ=X(JL)
      YJ=Y(JL)
      ZJ=Z(JL)
      T1XJ=T1X(JL)
      T1YJ=T1Y(JL)
      T1ZJ=T1Z(JL)
      T2XJ=T2X(JL)
      T2YJ=T2Y(JL)
      T2ZJ=T2Z(JL)
      CALL HINTG (XOB,YOB,ZOB)
      JC=JC+3
      ACX=T1XJ*CUR(JC-2)+T1YJ*CUR(JC-1)+T1ZJ*CUR(JC)
      BCX=T2XJ*CUR(JC-2)+T2YJ*CUR(JC-1)+T2ZJ*CUR(JC)
      HX=HX+ACX*EXK+BCX*EXS
      HY=HY+ACX*EYK+BCX*EYS
      HZ=HZ+ACX*EZK+BCX*EZS
5      CONTINUE
6      CONTINUE
C**
C     E      WRITE(*,*) '   NHFLD: RETURN'
C**
      RETURN
      END
C
C
C
      SUBROUTINE EFLD (XI,YI,ZI,AI,IJ)
C
C     COMPUTE NEAR E FIELDS OF A SEGMENT WITH SINE, COSINE, AND
C     CONSTANT CURRENTS.  GROUND EFFECT INCLUDED.
C
      INTEGER*4 IND1,IND2
      REAL*8 PI,TP,R,RMAG,XYMAG,XSPEC,YSPEC,RHOSPC,CTH,PX,PY,DMIN,
     1 SHAF,XI,YI,ZI
      COMPLEX*16 EGND(9),TXK,TYK,TZK,TXS,TYS,TZS,TXC,TYC,TZC,
     1 TEZS,TERS,TEZC,TERC,TEZK,TERK
      COMPLEX*16 EXK,EYK,EZK,EXS,EYS,ZRATI,ZRATI2,T1,FRATI,
     1 EZS,EXC,EYC,EZC,EPX,EPY,REFS,REFPS,ZRSIN,ZRATX,ZSCRN
      COMMON/DATAJ/S,B,XJ,YJ,ZJ,CABJ,SABJ,SALPJ,EXK,EYK,EZK,EXS,EYS,
     1 EZS,EXC,EYC,EZC,RKH,IND1,IND2,IPGND,IEXK
      COMMON/GND/ ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,
     1 IFAR,IPERF,T1,T2
      COMMON/INCOM/ XO,YO,ZO,SN,XSN,YSN,ISNOR
      EQUIVALENCE (EGND(1),TXK),(EGND(2),TYK),(EGND(3),TZK),(EGND(4),
     1TXS),(EGND(5),TYS),(EGND(6),TZS),(EGND(7),TXC),(EGND(8),TYC),
     2(EGND(9),TZC)
      DATA ETA/376.73/,PI/3.141592654D0/,TP/6.283185308D0/
C**
C     D      WRITE(*,*) '   EFLD: START'
C**
      XIJ=XI-XJ
      YIJ=YI-YJ
      IJX=IJ
      RFL=-1.
      DO 12 IP=1,KSYMP
      IF (IP.EQ.2) IJX=1
      RFL=-RFL
      SALPR=SALPJ*RFL
      ZIJ=ZI-RFL*ZJ
      ZP=XIJ*CABJ+YIJ*SABJ+ZIJ*SALPR
      RHOX=XIJ-CABJ*ZP
      RHOY=YIJ-SABJ*ZP
      RHOZ=ZIJ-SALPR*ZP
C      RH=DSQRT(RHOX*RHOX+RHOY*RHOY+RHOZ*RHOZ+AI*AI)
      RH=SQRT(RHOX*RHOX+RHOY*RHOY+RHOZ*RHOZ+AI*AI)
      IF (RH.GT.1.E-10) GO TO 1
      RHOX=0.
      RHOY=0.
      RHOZ=0.
      GO TO 2
1     RHOX=RHOX/RH
      RHOY=RHOY/RH
      RHOZ=RHOZ/RH
C2     R=DSQRT(ZP*ZP+RH*RH)
2     R=SQRT(ZP*ZP+RH*RH)
      IF (R.LT.RKH) GO TO 3
C
C     LUMPED CURRENT ELEMENT APPROX. FOR LARGE SEPARATIONS
C
      RMAG=TP*R
      CTH=ZP/R
      PX=RH/R
      TXK=DCMPLX(DCOS(RMAG),-DSIN(RMAG))
      PY=TP*R*R
      TYK=ETA*CTH*TXK*DCMPLX(1.,-1./RMAG)/PY
      TZK=ETA*PX*TXK*DCMPLX(1.,RMAG-1./RMAG)/(2.*PY)
      TEZK=TYK*CTH-TZK*PX
      TERK=TYK*PX+TZK*CTH
      RMAG=DSIN(PI*S)/PI
      TEZC=TEZK*RMAG
      TERC=TERK*RMAG
      TEZK=TEZK*S
      TERK=TERK*S
      TXS=(0.,0.)
      TYS=(0.,0.)
      TZS=(0.,0.)
      GO TO 6
3     IF (IEXK.EQ.1) GO TO 4
C
C     EKSC FOR THIN WIRE APPROX. OR EKSCX FOR EXTENDED T.W. APPROX.
C
      CALL EKSC (S,ZP,RH,TP,IJX,TEZS,TERS,TEZC,TERC,TEZK,TERK)
      GO TO 5
4      CONTINUE
      CALL EKSCX(B,S,ZP,RH,TP,IJX,IND1,IND2,TEZS,TERS,TEZC,TERC,TEZK,
     1TERK)
5     TXS=TEZS*CABJ+TERS*RHOX
      TYS=TEZS*SABJ+TERS*RHOY
      TZS=TEZS*SALPR+TERS*RHOZ
6     TXK=TEZK*CABJ+TERK*RHOX
      TYK=TEZK*SABJ+TERK*RHOY
      TZK=TEZK*SALPR+TERK*RHOZ
      TXC=TEZC*CABJ+TERC*RHOX
      TYC=TEZC*SABJ+TERC*RHOY
      TZC=TEZC*SALPR+TERC*RHOZ
      IF (IP.NE.2) GO TO 11
      IF (IPERF.GT.0) GO TO 10
      ZRATX=ZRATI
      RMAG=R
C      XYMAG=DSQRT(XIJ*XIJ+YIJ*YIJ)
      XYMAG=SQRT(XIJ*XIJ+YIJ*YIJ)
C
C     SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN.
C
      IF (NRADL.EQ.0) GO TO 7
      XSPEC=(XI*ZJ+ZI*XJ)/(ZI+ZJ)
      YSPEC=(YI*ZJ+ZI*YJ)/(ZI+ZJ)
      RHOSPC=DSQRT(XSPEC*XSPEC+YSPEC*YSPEC+T2*T2)
      IF (RHOSPC.GT.SCRWL) GO TO 7
      ZSCRN=T1*RHOSPC*DLOG(RHOSPC/T2)
      ZRATX=(ZSCRN*ZRATI)/(ETA*ZRATI+ZSCRN)
7     IF (XYMAG.GT.1.D-6) GO TO 8
C
C     CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED.
C
      PX=0.
      PY=0.
      CTH=1.
      ZRSIN=(1.,0.)
      GO TO 9
8     PX=-YIJ/XYMAG
      PY=XIJ/XYMAG
      CTH=ZIJ/RMAG
      ZRSIN=CDSQRT(1.-ZRATX*ZRATX*(1.-CTH*CTH))
9     REFS=(CTH-ZRATX*ZRSIN)/(CTH+ZRATX*ZRSIN)
      REFPS=-(ZRATX*CTH-ZRSIN)/(ZRATX*CTH+ZRSIN)
      REFPS=REFPS-REFS
      EPY=PX*TXK+PY*TYK
      EPX=PX*EPY
      EPY=PY*EPY
      TXK=REFS*TXK+REFPS*EPX
      TYK=REFS*TYK+REFPS*EPY
      TZK=REFS*TZK
      EPY=PX*TXS+PY*TYS
      EPX=PX*EPY
      EPY=PY*EPY
      TXS=REFS*TXS+REFPS*EPX
      TYS=REFS*TYS+REFPS*EPY
      TZS=REFS*TZS
      EPY=PX*TXC+PY*TYC
      EPX=PX*EPY
      EPY=PY*EPY
      TXC=REFS*TXC+REFPS*EPX
      TYC=REFS*TYC+REFPS*EPY
      TZC=REFS*TZC
10    EXK=EXK-TXK*FRATI
      EYK=EYK-TYK*FRATI
      EZK=EZK-TZK*FRATI
      EXS=EXS-TXS*FRATI
      EYS=EYS-TYS*FRATI
      EZS=EZS-TZS*FRATI
      EXC=EXC-TXC*FRATI
      EYC=EYC-TYC*FRATI
      EZC=EZC-TZC*FRATI
      GO TO 12
11    EXK=TXK
      EYK=TYK
      EZK=TZK
      EXS=TXS
      EYS=TYS
      EZS=TZS
      EXC=TXC
      EYC=TYC
      EZC=TZC
12    CONTINUE
      IF (IPERF.EQ.2) GO TO 13
C**
C     D      WRITE(*,*) '   EFLD: RETURN LINE 161'
C**
      RETURN
C
C     FIELD DUE TO GROUND USING SOMMERFELD/NORTON
C
C13    SN=DSQRT(CABJ*CABJ+SABJ*SABJ)
13    SN=SQRT(CABJ*CABJ+SABJ*SABJ)
      IF (SN.LT.1.E-5) GO TO 14
      XSN=CABJ/SN
      YSN=SABJ/SN
      GO TO 15
14    SN=0.
      XSN=1.
      YSN=0.
C
C     DISPLACE OBSERVATION POINT FOR THIN WIRE APPROXIMATION
C
15    ZIJ=ZI+ZJ
      SALPR=-SALPJ
      RHOX=SABJ*ZIJ-SALPR*YIJ
      RHOY=SALPR*XIJ-CABJ*ZIJ
      RHOZ=CABJ*YIJ-SABJ*XIJ
      RH=RHOX*RHOX+RHOY*RHOY+RHOZ*RHOZ
      IF (RH.GT.1.E-10) GO TO 16
      XO=XI-AI*YSN
      YO=YI+AI*XSN
      ZO=ZI
      GO TO 17
C16    RH=AI/DSQRT(RH)
16    RH=AI/SQRT(RH)
      IF (RHOZ.LT.0.) RH=-RH
      XO=XI+RH*RHOX
      YO=YI+RH*RHOY
      ZO=ZI+RH*RHOZ
17    R=XIJ*XIJ+YIJ*YIJ+ZIJ*ZIJ
      IF (R.GT..95) GO TO 18
C
C     FIELD FROM INTERPOLATION IS INTEGRATED OVER SEGMENT
C
      ISNOR=1
      DMIN=EXK*DCONJG(EXK)+EYK*DCONJG(EYK)+EZK*DCONJG(EZK)
      DMIN=.01*DSQRT(DMIN)
      SHAF=.5*S
      CALL ROM2 (-SHAF,SHAF,EGND,DMIN)
      GO TO 19
C
C     NORTON FIELD EQUATIONS AND LUMPED CURRENT ELEMENT APPROXIMATION
C
18    ISNOR=2
      CALL SFLDS (0.D0,EGND)
      GO TO 22
19    ZP=XIJ*CABJ+YIJ*SABJ+ZIJ*SALPR
      RH=R-ZP*ZP
      IF (RH.GT.1.E-10) GO TO 20
      DMIN=0.
      GO TO 21
C20    DMIN=DSQRT(RH/(RH+AI*AI))
20    DMIN=SQRT(RH/(RH+AI*AI))
21    IF (DMIN.GT..95) GO TO 22
      PX=1.-DMIN
      TERK=(TXK*CABJ+TYK*SABJ+TZK*SALPR)*PX
      TXK=DMIN*TXK+TERK*CABJ
      TYK=DMIN*TYK+TERK*SABJ
      TZK=DMIN*TZK+TERK*SALPR
      TERS=(TXS*CABJ+TYS*SABJ+TZS*SALPR)*PX
      TXS=DMIN*TXS+TERS*CABJ
      TYS=DMIN*TYS+TERS*SABJ
      TZS=DMIN*TZS+TERS*SALPR
      TERC=(TXC*CABJ+TYC*SABJ+TZC*SALPR)*PX
      TXC=DMIN*TXC+TERC*CABJ
      TYC=DMIN*TYC+TERC*SABJ
      TZC=DMIN*TZC+TERC*SALPR
22    EXK=EXK+TXK
      EYK=EYK+TYK
      EZK=EZK+TZK
      EXS=EXS+TXS
      EYS=EYS+TYS
      EZS=EZS+TZS
      EXC=EXC+TXC
      EYC=EYC+TYC
      EZC=EZC+TZC
C**
C     D      WRITE(*,*) '   EFLD: RETURN LINE 241'
C**
      RETURN
      END
